#|

specification:

func-expr:
  func {func-name} ({func-arglist}) &optional block-expression

func-arglist:
  {(type name)}*

block-expression:
  {expr}*

expr:
  (call func-name {inner-expr}*)
  (let {var-name} {inner-expr})
  (set {var-name} {inner-expr})
  (if {inner-expr} {expr then} {expr else})

inner-expr:
  var
  number
  string
  ({+,-,*,/,>,<,<=,>=,==,!=} inner-expr inner-expr)
  (!,~ inner-expr)
  

|#

;; =============================================================================
;; marked code
(defvar *marked-parser-code*
  '(
    ;; external entities definition
    (extern
     (func foo (expr)))

    ;; parse functions
    (func toplev-expr (expr)
     (foo expr))
    ))

(defvar *transformation*
  '(
    ;; transform marked-parser-code
    (marked-transform *marked-parser-code*
     ;; transformation change event
     (change
      (:type func)
      ;; returns the same list but transformed
      (:transform (name args body)
		  ;; transformed outcome
		  (
		   ;; name
		   (intern (concatenate 'string "ri-parser-" (princ-to-string name)))
		   ;; args
		   (append (list context) args)
		   ;; body
		   (append (list (ri-analyzer-enter-expr context)) body (list ()))
		   )
		  )
      )					; end of change
     )
    ))

(defvar *expected-outcome*
  '(
    (defun ri-parser-toplev-expr (c expr)
      (ri-analyzer-enter-expr c expr)
      (foo expr)
      (ri-analyzer-leave-expr c expr))
    ))


;; =============================================================================
;; analyzer

;; accepts function expression
(defun ri-analyzer-accept-func (c func-name arg-list body-block)
  (list func-name))

;; argument at the function declaration
(defun ri-analyzer-accept-funcdecl-arg (c argtype argname)
  (list argtype argname))

;; type expression
(defun ri-analyzer-accept-type (c type-expr)
  type-expr)

(defun ri-analyzer-on-enter-scope (c expr)
  (format t "on-enter ~a~%" expr))

(defun ri-analyzer-on-leave-scope (c expr)
  (format t "on-leave ~a~%" expr))

;; =============================================================================
;; parser

(defmacro pfun (name (c &rest arglist) &rest body)
  (let ((func-result (gensym "func-result-")))
  `(defun
    ;; discover new name
    ,(intern (concatenate 'string "ri-parser-" (princ-to-string name)))
    ;; arglist
    (,c ,@arglist)
    ;; body
    (ri-analyzer-on-enter-scope ,c ',name)
    (let ((,func-result ,@body))
      (ri-analyzer-on-leave-scope ,c ',name)
      ,func-result))))

(pfun func1 (a b) (list a b))

;; (ri-parser-func1 1 2)

;; process type declaration
(defun ri-parser-process-type-decl (c type-decl)
  ;; for now we assume type decl is just a symbol
  (check-type type-decl symbol)
  (ri-analyzer-accept-type c type-decl))

;; process argument name
(defun ri-parser-process-type-decl (c type-decl)
  ;; for now we assume type decl is just a symbol
  (check-type type-decl symbol)
  (ri-analyzer-accept-type c type-decl))

;; process argument in the function declaration
(defun ri-parser-process-funcdecl-arg (c arg-expr)
  ())


;; process block expression
(defun ri-parser-process-block (c block-expr))

(defun ri-parser-process-toplev (c toplev-expr)
  (let ((toplev-expr-id (car toplev-expr)) (toplev-expr-args (cdr toplev-expr)))
    (case toplev-expr-id
      ('func (destructuring-bind
		   (f-name (&rest f-args) &rest f-body) toplev-expr-arg	       
	     ;; pass to analyzer
	     (ri-analyzer-accept-func
	      c
	      f-name
	      (loop for arg in f-args collect (ri-parser-process-funcdecl-arg c arg))
	      f-body)))
      (t (error "can't handle toplev expr")))))

;; =============================================================================
;; ri test

;; function trait
(defstruct (func-traits (:conc-name ft-))
  (name nil :type symbol)         ; e.g. fopen
  (args nil :type list)           ; e.g. ((c-char-p name) (c-char-p mode))
  (result nil :type cons)         ; e.g. (file-p file)
  )

;; allocator traits
(defstruct (alloc-func-traits (:include func-traits) (:conc-name ft-))
  (free-func nil :type func-traits))


;; =============================================================================
;; parsing context

;; single function definition
(defstruct (func-def (:conc-name fd-))
  (forward-p nil :type boolean)
  (decl-body nil :type list))

;; parsing context
(defstruct (rit-context (:conc-name pc-))
  (func-defs nil :type hash-table))

;; parses arbitrary block
(defun rit-process-block (func-def block-expr))

;; parse function block at the first level
(defun rit-process-function-block (c func-def)
  (let ((block-expr (fd-decl-body func-def)))
    (format t "process func block")))

;; parses tolpev definition
(defun rit-process-toplev (c toplev-expr)
  (let ((func-id (car toplev-expr)) (func-args (cdr toplev-expr)))
    (case func-id
      ('func (destructuring-bind
		   (new-f-name (&rest new-f-args) &rest new-f-body) func-args
	       ;; body

	       ;; checks
	       (let ((func-defs-table (pc-func-defs c))
		     f-d)
		 (setf f-d (gethash new-f-name func-defs-table))
		 
		 ;; check that function has not been declared twice
		 (if f-d
		     ;; function forward?
		     (if (fd-forward-p f-d)
			 ;; forward sanity check
			 (progn
			   ;; twice redeclaration is forbidden (TODO: allow it?)
			   (if (null new-f-body) (error "multiple redeclaration is not allowed"))
			   ;; not equal arglists
			   (if (not (equal new-f-args (car (fd-decl-body f-d))))
			       (error "arglist at the forwarded version does not match given one")))
			 ;; redeclared
			 (error "func declared twice")))

		 ;; declare function
		 (setf f-d (make-func-def
			    :forward-p (null new-f-body)
			    :decl-body (list new-f-args new-f-body)))
		 (setf (gethash new-f-name (pc-func-defs c)) f-d)

		 ;; traverse over each body declaration
		 (if new-f-body (rit-process-function-block c f-d)))))
      (t (error "can't handle toplev expr")))))

;; toy lang in lisp: parses sequence given
(defun rit-parse (&rest toplev-seq)
  (let ((c (make-rit-context :func-defs (make-hash-table))))
    (dolist (toplev-expr toplev-seq)
      (rit-process-toplev c toplev-expr))))

;; (rit-parse '(func foo ((int a))) '(func foo ((int a)) (do1)))

(defparameter *sample-ri-source*
  '(
    ;; mystruct
    (struct MyStruct
     (int a)
     (double b))


    ;; func 2, usage
    (func f2 ((void-p a))
     (memset a 0 (sizeof a)))
    
    ;; func 1, entry point
    (func (int main) ()
     (let (void-p a) (malloc (size-of MyStruct)))
     (f2 a)
     ;; a shall be deleted here
     (return 0))
    ))
